Tech Arsenal 1/Tech Arsenal (Arsenal Computer).ISO/tek-02/drawer.zip/SHAPE.PAS

Pascal/Delphi Source File | 1993-01-04 | 15KB | 709 lines

{$L-,D-}

unit Shapes;

interface

const
    HITTOLERANCE : word = 301;
    HITPOINTTOLERANCE : word = 4;

type
    ShapeTypes = ( sShape, sRectangle, sFRectangle, sEllipse, sFEllipse, sLine, sGText, sSelector);
    Shape = object
                typ      : ShapeTypes;
                x, y     : word;        { position }
                xe, ye   : integer;        { extent }
                color    : word;        { color }
                selected : boolean;     { state of selection }
                procedure Error( s : string );
                procedure Initialize( x, y, xe, ye, color : word);
                function  Clone : shape;
                procedure Draw;
                procedure Erase;
                function  PtInRegion( px, py : word ) : boolean;
                procedure Select;
                procedure UnSelect;
                function  IsSelected : boolean;
                procedure Size( dx, dy : integer);
                procedure Move( dx, dy : word);
                procedure DrawHandles;
                function  OnHandle( px, py : word; var ax, ay : word) : boolean;
                procedure Save( var f : file );
                procedure Load( var f : file );
            end;

    Rectangle = object(Shape)
                    procedure Initialize(x, y, xe, ye, color : word); override;
                    function  Clone : shape; override;
                    procedure Load( var f : file ); override;
                end;

    FRectangle =    object(Rectangle)
                        procedure Initialize(x, y, xe, ye, color : word); override;
                        function  Clone : shape; override;
                        procedure Load( var f : file ); override;
                        procedure Draw; override;
                        procedure Erase; override;
                    end;

    Ellipse =     object(Shape)
                    procedure Initialize(x, y, xe, ye, color : word); override;
                    function  Clone : shape; override;
                    procedure Load( var f : file ); override;
                    procedure Draw; override;
                    procedure Erase; override;
                end;

    FEllipse =     object(Ellipse)
                    procedure Initialize(x, y, xe, ye, color : word); override;
                    function  Clone : shape; override;
                    procedure Load( var f : file ); override;
                    procedure Draw; override;
                    procedure Erase; override;
                end;

    Line =    object(Shape)
                procedure Initialize(x, y, xe, ye, color : word); override;
                function  Clone : shape; override;
                procedure Load( var f : file ); override;
                procedure Draw; override;
                procedure DrawHandles; override;
                procedure Select; override;
                procedure UnSelect; override;
                function  PtInRegion( px, py : word) : boolean; override;
                function  OnHandle( px, py : word; var ax, ay : word) : boolean; override;
            end;

    GText =    object(Shape)
                data : string;
                procedure Initialize(x, y, xe, ye, color : word); override;
                function  Clone : shape; override;
                procedure Save( var f : file ); override;
                procedure Load( var f : file ); override;
                procedure SetText( s : string );
                procedure SetHeight( h : word );
                procedure Size( dx, dy : integer); override;
                procedure Draw;    override;
                procedure Erase; override;
            end;

    Selector =    object(Shape)
                    procedure Initialize(x, y, xe, ye, color : word); override;
                    function  Clone : shape; override;
                    procedure Load( var f : file ); override;
                    procedure Draw; override;
                end;

implementation

uses MSGraph, Utility;

const
    TypeFace = 'bt''tms rmn''';
    CurrentHeight : word = 0;

var
    CurrentFontInfo : _FontInfo;

{ utilities }

function GSetFont( h : word) : boolean;
var
    fs : string[32];
    nstr : string[5];
begin
    { see if trivial case }
    if h=CurrentHeight then begin
        GSetFont := TRUE;
        exit;
        end;

    { create net font selector }
    fs := TypeFace;
    str( h, nstr);
    fs := fs + 'h' + nstr;

    { try to select font }
    if    (_SetFont(fs)>0) and
        (_GetFontInfo(CurrentFontInfo)<>-1) then begin
        CurrentHeight := h;
        GSetFont := TRUE;
        end
    else
        GSetFont := FALSE;
end;

procedure DrawHandle( x, y : word);
const
    HHEIGHT = 4;            { handle height }
    HWIDTH  = 4;            { handle width  }
    HHD2    = HHEIGHT div 2;
    HWD2    = HWIDTH  div 2;

    {*
    ** Image:  handle
    ** Size:   24 bytes
    ** Extent: 4,4
    *}
    handle : array[1..24] of byte = (
                     5,0,5,0,240,240,240,240,240,240,240,240,240,240,
                     240,240,240,240,240,240,0,0,0,0);
begin
    _PutImage( x-HWD2, y-HHD2, handle, _GXOR);
end;

{
    Returns TRUE if points are "near" each other
}
function Near( x1, y1, x2, y2 : word) : boolean;
begin
    Near :=    (abs(y2-y1) < HITPOINTTOLERANCE) and
            (abs(x2-x1) < HITPOINTTOLERANCE);
end;

procedure Shape.DrawHandles;
begin
    with self do begin
        DrawHandle( x,         y);
        DrawHandle( x+xe,    y);
        DrawHandle( x,         y+ye);
        DrawHandle( x+xe,     y+ye);
        end;
end;

procedure Shape.Error( s : string);
begin
{
    writeln( s );
    RunError(182);
}
end;

procedure Shape.Initialize( x, y, xe, ye, color : word);
begin
    self.typ := sShape;
    self.x := x;
    self.y := y;
    self.xe := xe;
    self.ye := ye;
    self.color    := color;
    self.selected := false;
end;

function Shape.Clone : shape;
var
    s : Shape;
begin
    new(s);
    with self do
        s.Initialize( x, y, xe, ye, color);
    Clone := s;
end;

procedure Shape.Draw;
begin
    with self do begin
        _SetColor(color);
        _SetWriteMode( _GXOR );
        _SetLineStyle($FFFF);
        _Rectangle( _GBORDER, x, y, x+xe, y+ye);
        if Selected then DrawHandles;
        end;
end;

procedure Shape.Erase;
begin
    self.Draw;
end;

function Shape.PtInRegion( px, py : word) : boolean;
var
    xl, xh : word;
    yl, yh : word;


begin
    with self do begin
        xl := min( x, x+xe);
        xh := max( x, x+xe);
        yl := min( y, y+ye);
        yh := max( y, y+ye);
        PtInRegion :=    (px>=xl) and (px<=xh) and
                        (py>=yl) and (py<=yh);
        end;
end;

procedure Shape.Select;
begin
    if not self.Selected then begin
        self.DrawHandles;
        self.Selected := TRUE;
        end;
end;

procedure Shape.UnSelect;
begin
    if self.Selected then begin
        self.DrawHandles;
        self.Selected := FALSE;
        end;
end;

function Shape.IsSelected : boolean;
begin
    IsSelected := self.Selected;
end;

{
    If on a handle, returns TRUE and sets ax and ay to the anchor point
}
function Shape.OnHandle( px, py : word; var ax, ay : word ) : boolean;
begin
    with self do
        if not Selected then OnHandle := FALSE
        else if Near( px, py, x, y) then begin
            ax := x+xe;
            ay := y+ye;
            OnHandle := TRUE;
            end
        else if Near( px, py, x+xe, y+ye) then begin
            ax := x;
            ay := y;
            OnHandle := TRUE;
            end
        else if Near( px, py, x+xe, y) then begin
            ax := x;
            ay := y+ye;
            OnHandle := TRUE;
            end
        else if Near( px, py, x, y+ye) then begin
            ax := x+xe;
            ay := y;
            OnHandle := TRUE;
            end
        else OnHandle := FALSE;
end;

procedure Shape.Size( dx, dy : integer );
begin
    inc( self.xe, dx);
    inc( self.ye, dy);
end;

procedure Shape.Move( dx, dy : word );
begin
    inc( self.x, dx);
    inc( self.y, dy);
end;

(*
                typ      : ShapeTypes;
                x, y     : word;        { position }
                xe, ye   : integer;        { extent }
                color    : word;        { color }
                selected : boolean;     { state of selection }
*)
procedure Shape.Save( var f : file );
var
    written : word;
begin
    with self do begin
        BlockWrite( f, typ,        sizeof(typ),    written);
        BlockWrite( f, x,           sizeof(x),        written);
        BlockWrite( f, y,          sizeof(y),        written);
        BlockWrite( f, xe,        sizeof(xe),        written);
        BlockWrite( f, ye,        sizeof(ye),        written);
        BlockWrite( f, color,    sizeof(color),    written);
        end;
end;

{ it is assume that the typ field has been read already }
procedure Shape.Load( var f : file );
var
    numread : word;
begin
    with self do begin
        typ := sShape;
        BlockRead( f, x,           sizeof(x),        numread);
        BlockRead( f, y,          sizeof(y),        numread);
        BlockRead( f, xe,        sizeof(xe),        numread);
        BlockRead( f, ye,        sizeof(ye),        numread);
        BlockRead( f, color,    sizeof(color),    numread);
        end;
end;

procedure Rectangle.Initialize(x, y, xe, ye, color : word);
begin
    inherited self.Initialize(x, y, xe, ye, color );
    self.typ := sRectangle;
end;

function Rectangle.Clone : shape;
var
    s : Rectangle;
begin
    new(s);
    with self do
        s.Initialize( x, y, xe, ye, color);
    Clone := s;
end;

procedure Rectangle.Load( var f : file);
begin
    inherited self.Load( f );
    with self do Initialize( x, y, xe, ye, color);
end;

procedure FRectangle.Initialize(x, y, xe, ye, color : word);
begin
    inherited self.Initialize(x, y, xe, ye, color );
    self.typ := sFRectangle;
end;

function FRectangle.Clone : shape;
var
    s : FRectangle;
begin
    new(s);
    with self do
        s.Initialize( x, y, xe, ye, color);
    Clone := s;
end;

procedure FRectangle.Load( var f : file);
begin
    inherited self.Load( f );
    with self do Initialize( x, y, xe, ye, color);
end;

procedure FRectangle.Draw;
begin
    with self do begin
        _SetColor(color);
        _Rectangle( _GFILLINTERIOR, x, y, x+xe, y+ye);
        if self.Selected then self.DrawHandles;
        end;
end;

procedure FRectangle.Erase;
begin
    with self do begin
        if selected then self.DrawHandles;
        _SetColor(0);
        _Rectangle( _GFILLINTERIOR, x, y, x+xe, y+ye);
        end;
end;

procedure Ellipse.Initialize(x, y, xe, ye, color : word);
begin
    inherited self.Initialize(x, y, xe, ye, color );
    self.typ := sEllipse;
end;

function Ellipse.Clone : shape;
var
    s : Ellipse;
begin
    new(s);
    with self do
        s.Initialize( x, y, xe, ye, color);
    Clone := s;
end;

procedure Ellipse.Load( var f : file);
begin
    inherited self.Load( f );
    with self do Initialize( x, y, xe, ye, color);
end;

procedure Ellipse.Draw;
begin
    with self do begin
        _SetColor(color);
        _Ellipse( _GBORDER, x, y, x+xe, y+ye);
        if self.Selected then self.DrawHandles;
        end;
end;

procedure Ellipse.Erase;
begin
    if self.Selected then self.DrawHandles;
    _SetColor(0);
    with self do _Ellipse( _GBORDER, x, y, x+xe, y+ye);
end;

procedure FEllipse.Initialize(x, y, xe, ye, color : word);
begin
    inherited self.Initialize(x, y, xe, ye, color );
    self.typ := sFEllipse;
end;

function FEllipse.Clone : shape;
var
    s : FEllipse;
begin
    new(s);
    with self do
        s.Initialize( x, y, xe, ye, color);
    Clone := s;
end;

procedure FEllipse.Load( var f : file);
begin
    inherited self.Load( f );
    with self do Initialize( x, y, xe, ye, color);
end;

procedure FEllipse.Draw;
begin
    with self do begin
        _SetColor(color);
        _Ellipse( _GFILLINTERIOR, x, y, x+xe, y+ye);
        if self.Selected then self.DrawHandles;
        end;
end;

procedure FEllipse.Erase;
begin
    with self do begin
        if Selected then self.DrawHandles;
        _SetColor(0);
        _Ellipse( _GFILLINTERIOR, x, y, x+xe, y+ye);
        end;
end;

procedure Line.Initialize(x, y, xe, ye, color : word);
begin
    inherited self.Initialize(x, y, xe, ye, color );
    self.typ := sLine;
end;

function Line.Clone : shape;
var
    s : Line;
begin
    new(s);
    with self do
        s.Initialize( x, y, xe, ye, color);
    Clone := s;
end;

procedure Line.Load( var f : file);
begin
    inherited self.Load( f );
    with self do Initialize( x, y, xe, ye, color);
end;

procedure Line.Draw;
begin
    _SetWriteMode(_GXOR);
    _SetLineStyle( $FFFF );
    with self do begin
        _SetColor(color);
        _MoveTo(x, y);
        _LineTo(x+xe, y+ye);
        if self.Selected then self.DrawHandles;
        end;
end;

procedure Line.DrawHandles;
begin
    with self do begin
        DrawHandle( x, y);
        DrawHandle( x+xe, y+ye);
        end;
end;

procedure Line.Select;
begin
    if not self.Selected then begin
        self.DrawHandles;
        self.Selected := TRUE;
        end;
end;

procedure Line.UnSelect;
begin
    if self.Selected then begin
        self.DrawHandles;
        self.Selected := FALSE;
        end;
end;

function Line.PtInRegion(px, py : word) : boolean;
var
    Distance : longint;
    xl, xh, yl, yh : word;
begin
    with self do begin
        xl := min( x, x+xe);
        xh := max( x, x+xe);
        yl := min( y, y+ye);
        yh := max( y, y+ye);
        if     (px<xl) or (px>xh) or
            (py<yl) or (py>yh) then PtInRegion := FALSE
        else begin
            Distance := abs(longint(ye)*(longint(x)-px) -
                            longint(xe)*(longint(y)-py) );
            PtInRegion := Distance < HITTOLERANCE;
            end;
        end;
end;

{
    If on a handle, returns TRUE and sets ax and ay to the anchor point
}
function Line.OnHandle( px, py : word; var ax, ay : word ) : boolean;
begin
    with self do
        if not Selected then OnHandle := FALSE
        else if Near( px, py, x, y) then begin
            ax := x+xe;
            ay := y+ye;
            OnHandle := TRUE;
            end
        else if Near( px, py, x+xe, y+ye) then begin
            ax := x;
            ay := y;
            OnHandle := TRUE;
            end
        else OnHandle := FALSE;
end;

procedure GText.Initialize( x, y, xe, ye, color : word);
begin
    inherited self.Initialize(x, y, xe, ye, color);
    self.typ := sGText;
    self.data := '';

    if GSetFont(ye)
        then self.ye :=CurrentFontInfo.PixHeight
        else self.ye := 0;

    self.xe := 0;
end;

function GText.Clone : shape;
var
    s : GText;
begin
    new(s);
    with self do begin
        s.Initialize( x, y, xe, ye, color);
        s.SetText( data );
        end;
    Clone := s;
end;

procedure GText.Save( var f : file );
var
    written : word;
    l : byte;
begin
    with self do begin
        inherited Save(f);
        l := length(data);
        BlockWrite( f, l, sizeof(l), written);
        BlockWrite( f, pointer(@data[1])^, l, written);
        end;
end;

procedure GText.Load( var f : file);
var
    numread : word;
    l : byte;
    d : string;
begin
    inherited self.Load( f );
    BlockRead( f, l, sizeof(l), numread);
    d[0] := chr(l);
    BlockRead( f, pointer(@d[1])^, l, numread);
    with self do begin
        Initialize( x, y, xe, ye, color);
        SetText( d );
        end;
end;

procedure GText.SetText( s : string);
begin
    self.data := s;
    self.xe := _GetGTextExtent(s);
end;

procedure GText.SetHeight( h : word );
begin
    if GSetFont( h ) then begin
        self.ye := CurrentFontInfo.PixHeight;
        self.xe := _GetGTextExtent( self.data );
        end;
end;

procedure GText.Size( dx, dy : integer); override;
begin
    self.SetHeight( self.ye+dy );
end;

procedure GText.Draw;
begin
    with self do begin
        _MoveTo( x, y);
        if not GSetFont(ye) then self.Error('Unable to set font');
        _SetColor( color );
        _OutGText( data );
        if Selected then self.DrawHandles;
        end;
end;

procedure GText.Erase;
begin
    with self do begin
        if Selected then self.DrawHandles;
        _SetColor(0);
        _Ellipse( _GFILLINTERIOR, x, y, x+xe, y+ye);
        end;
end;

procedure Selector.Initialize(x, y, xe, ye, color : word);
begin
    inherited self.Initialize(x, y, xe, ye, color );
    self.typ := sSelector;
end;

function Selector.Clone : shape;
var
    s : Selector;
begin
    new(s);
    with self do
        s.Initialize( x, y, xe, ye, color);
    Clone := s;
end;

procedure Selector.Load( var f : file);
begin
    inherited self.Load( f );
    with self do Initialize( x, y, xe, ye, color);
end;

procedure Selector.Draw;
var
    ax, ay : word;
begin
    with self do begin
        ax := xe div 4;
        ay := ye div 4;
        _SetColor(color);
        _SetWriteMode( _GXOR );
        _MoveTo( x+ax, y+ye-ay);
        _LineTo( x+xe-ax, y+ay);
        _MoveTo( x+xe-(ax+ax), y+ay);
        _LineTo( x+xe-ax, y+ay);
        _LineTo( x+xe-ax, y+ay+ay);
        if Selected then self.DrawHandles;
        end;
end;

begin
end.